PsL Monthly 1993 December/PSL Monthly Shareware CD-ROM (December 1993).iso/prgmming/dos/pascal/sthing.com/STHING.PAS

Pascal/Delphi Source File | 1990-10-28 | 8.9 KB | 349 lines

{
  STHING.PAS. Turbo Pascal interface to Covox Speech Thing. See STHING.DOC for
  further information.

  Written 10/90, Kim Kokkonen, TurboPower Software
  Copyright (C) 1990, TurboPower Software. All rights reserved.
}

{$R-,S-,I-,V-,B-,F+,O-,A-}

unit Sthing;
  {-Direct interface to SPEECHV2 or SPEECHV2}

interface

const
  StAllocFromHeap : Boolean = True;
  {Set to False if TP program will leave DOS memory free for
   allocation of words stored in dictionary.}

{----------------  basic functions  -------------------------------}

function StLoaded : Boolean;
  {-Returns True if SPEECHVx is loaded}

procedure StSetPort(Port : Word);
  {-Set peripheral port where speaker output goes. Default to LPT1 port}

procedure StSetLptPort(LPTNumber : Byte);
  {-Set peripheral port for LPT 1, 2, or 3}

procedure StSpeak(St : string);
  {-Speak the specified english string}

procedure StSetParams(Tone, Volume, Pitch, Speed : Word);
  {-Set parameters}
  {   param  valid range  default
      ------ -----------  -------
      Tone     0..1          0
      Volume   0..9          5
      Pitch    0..9          5
      Speed    0..9          5
   StSetParams does not range-check the values it receives.
  }

procedure StGetParams(var Tone, Volume, Pitch, Speed : Word);
  {-Get the last parameters set}

procedure StGrabInt7E;
  {-Modify abort-speech-on-keypressed behavior: SPEECHV3 only}

procedure StRestoreInt7E;
  {-Restore abort-speech-on-keypressed behavior}

procedure StUnload;
  {-Unload SPEECHV2 or SPEECHV3 from memory}

{----------------  phonetic speech functions  ---------------------}

procedure StTextToPhonetic(TextSt : string; var PhonSt : string);
  {-Convert text string to phonetic}

procedure StPhoneticSpeak(St : string);
  {-Speak the specified phonetic string}

{----------------  dictionary functions  --------------------------}

procedure StInitDict(Clear : Boolean);
  {-Reset the dictionary. Clear = True wipes all entries}

function StInsertDict(TextSt : string; PhonSt : string) : Boolean;
  {-Insert a new entry in dictionary. Returns False if insuff memory}

procedure StRemoveDict(TextSt : string);
  {-Remove an entry previously added to dictionary}
  {Note: when StAllocFromHeap is True, heap space is NOT reclaimed}

procedure StDumpDict(var TextSt : string; var PhonSt : string);
  {-Call repeatedly to get dictionary entries}
  {Example:
     StInitDict(False);
     StDumpDict(TextSt, PhonSt);
     while TextSt <> '' do begin
       writeln(TextSt:40, PhonSt:40);
       StDumpDict(TextSt, PhonSt);
     end;
  }

function StWriteDictFile(FName : string) : Word;
  {-Write dictionary to text file, returning status}

function StReadDictFile(FName : string) : Word;
  {-Read dictionary from text file, returning status}

const
  {Interesting stats for dictionary memory allocation}
  AlloCnt : LongInt = 0; {Number of allocations}
  ParaReq : LongInt = 0; {Paragraphs requested}
  BumpCnt : LongInt = 0; {Number of times we had to bump the para count}

  {====================================================================}

implementation

var
  SpeechPtr : pointer;              {Entry pointer for SPEECHVx}
  lUnknown : Word;                  {May be 0 or 1. Has no discernable effect}
  lTone : Word;                     {Last values for tone, etc.}
  lVolume : Word;
  lPitch : Word;
  lSpeed : Word;
  Int21Err : Word;                  {Error for dict memory allocation}
  SaveExit : Pointer;
  Have21 : Boolean;
  Have7E : Boolean;
  Loaded : Boolean;                 {True if SPEECHVx loaded}
  SaveSP : Word;                    {Keep SPEECHVx from corrupting stack}

function StLoaded : Boolean;
begin
  StLoaded := Loaded;
end;

{$L STHING.OBJ}
procedure StInit; external;
procedure StSetPort(Port : Word); external;
procedure StSetLptPort(LPTNumber : Byte); external;
procedure StSetParams(Tone, Volume, Pitch, Speed : Word); external;
procedure StSpeak(St : string); external;
procedure StTextToPhonetic(TextSt : string; var PhonSt : string); external;
procedure StPhoneticSpeak(St : string); external;
procedure StInitDict(Clear : Boolean); external;
function StInsertDict(TextSt : string; PhonSt : string) : Boolean; external;
procedure StRemoveDict(TextSt : string); external;
procedure StDumpDict(var TextSt : string; var PhonSt : string); external;
procedure StGrabInt7E; external;
procedure StRestoreInt7E; external;
procedure StGrabInt21; external;
procedure StRestoreInt21; external;
procedure StUnload; external;

{$F-}
function AllocSeg(Paras : Word) : Word;
  {-Paragraph allocator called from assembly language}
type
  OS = record O, S : Word end;
var
  Avail : LongInt;
  Bytes : Word;
  P : Pointer;
begin
  inc(AlloCnt);
  inc(ParaReq, Paras);
  AllocSeg := 0;
  if Paras <= $0FFF then begin
    Bytes := Paras shl 4;
    Avail := MemAvail;
    if Avail >= Bytes then begin
      GetMem(P, Bytes);
      if OS(P).O = 0 then
        AllocSeg := OS(P).S
      else begin
        FreeMem(P, Bytes);
        inc(Bytes, 15);
        inc(BumpCnt);
        if Avail >= Bytes then begin
          GetMem(P, Bytes);
          if OS(P).O = 0 then
            AllocSeg := OS(P).S
          else
            AllocSeg := OS(P).S+1;
        end;
      end;
    end;
  end;
end;
{$F+}

procedure StGetParams(var Tone, Volume, Pitch, Speed : Word);
begin
  Tone := lTone;
  Volume := lVolume;
  Pitch := lPitch;
  Speed := lSpeed;
end;

procedure Pad(var S : String; Len : Byte);
var
  SLen : byte absolute S;
begin
  if SLen >= Len then
    S := S+' '
  else begin
    FillChar(S[SLen+1], Len-SLen, ' ');
    SLen := Len;
  end;
end;

function StWriteDictFile(FName : string) : Word;
var
  Status : word;
  TextSt : string;
  PhonSt : string;
  F : text;
begin
  if not Loaded then begin
    StWriteDictFile := $FFFF;
    Exit;
  end;

  assign(F, FName);
  rewrite(F);
  Status := IoResult;
  if Status <> 0 then begin
    StWriteDictFile := Status;
    Exit;
  end;

  StInitDict(False);
  StDumpDict(TextSt, PhonSt);
  while TextSt <> '' do begin
    Pad(TextSt, 32);
    writeln(F, TextSt, PhonSt);
    Status := IoResult;
    if Status <> 0 then begin
      StWriteDictFile := Status;
      close(F);
      Status := IoResult;
      Exit;
    end;
    StDumpDict(TextSt, PhonSt);
  end;

  close(F);
  StWriteDictFile := IoResult;
end;

function StReadDictFile(FName : string) : Word;
var
  Status : word;
  BPos : byte;
  CPos : byte;
  St : string;
  F : text;
begin
  if not Loaded then begin
    StReadDictFile := $FFFF;
    Exit;
  end;

  assign(F, FName);
  reset(F);
  Status := IoResult;
  if Status <> 0 then begin
    StReadDictFile := Status;
    Exit;
  end;

  while not Eof(F) do begin
    ReadLn(F, St);
    if Length(St) <> 0 then
      if St[1] <> ';' then begin
        BPos := pos(' ', St);
        if BPos <> 0 then begin
          CPos := BPos;
          while (CPos <= Length(St)) and (St[CPos] = ' ') do
            inc(CPos);
          if CPos <= Length(St) then begin
            if not StInsertDict(Copy(St, 1, BPos-1),
                                Copy(St, CPos, Length(St)-CPos+1))
            then begin
              StReadDictFile := 8;
              Close(F);
              Status := IoResult;
              Exit;
            end;
          end else begin
            StReadDictFile := 106;
            Close(F);
            Status := IoResult;
            Exit;
          end;
        end else begin
          StReadDictFile := 106;
          Close(F);
          Status := IoResult;
          Exit;
        end;
      end;
  end;
  close(F);
  StReadDictFile := IoResult;
end;

procedure FindSpeech;
const
  MinIntr = $60;
  MaxIntr = $FD;
  IntsToCheck : set of MinIntr..MaxIntr =
    {Interrupts that SPEECHV2 or SPEECHV3 may take over on various machines}
    [$60..$67, $F1..$F7, $F9, $FC..$FD];
var
  Vectors : array[0..$FF] of pointer absolute $0:$0;
  Intr : Byte;
begin
  for Intr := MinIntr to MaxIntr do
    if Intr in IntsToCheck then begin
      SpeechPtr := Vectors[Intr];
      if LongInt(SpeechPtr^) = $FB3C0B3C then begin
        {Skip over dummy instructions}
        inc(LongInt(SpeechPtr), 4);
        Loaded := True;
        Exit;
      end;
    end;
  Loaded := False;
end;

procedure StExit;
begin
  ExitProc := SaveExit;
  StRestoreInt7E;
  StRestoreInt21; {Checks to see if Have21 is True}
end;

begin
  FindSpeech;
  if Loaded then begin
    {Set up for default LPT1 port}
    StSetPort(0);

    {Initialize SPEECHV2 or SPEECHV3}
    StInit;

    {Set default speech parameters}
    lUnknown := 0;
    StSetParams(0, 5, 5, 5);

    {Take over int 7E, which determines when to throw away keys}
    Have7E := False;
    StGrabInt7E;

    {Set up exit handler to restore vectors in case of error}
    Have21 := False;
    SaveExit := ExitProc;
    ExitProc := @StExit;
  end;
end.